home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / menus.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-29  |  37.2 KB  |  1,360 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,97 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit Menus;
  11.  
  12. {$S-,W-,R-}
  13. {$C PRELOAD}
  14.  
  15. interface
  16.  
  17. uses Windows, SysUtils, Classes, Messages;
  18.  
  19. const
  20.   scShift = $2000;
  21.   scCtrl = $4000;
  22.   scAlt = $8000;
  23.   scNone = 0;
  24.  
  25. type
  26.   EMenuError = class(Exception);
  27.   TMenu = class;
  28.   TMenuBreak = (mbNone, mbBreak, mbBarBreak);
  29.   TShortCut = Low(Word)..High(Word);
  30.   TMenuChangeEvent = procedure (Sender: TObject; Rebuild: Boolean) of object;
  31.   TMenuItem = class(TComponent)
  32.   private
  33.     FCaption: string;
  34.     FHandle: HMENU;
  35.     FChecked: Boolean;
  36.     FEnabled: Boolean;
  37.     FDefault: Boolean;
  38.     FRadioItem: Boolean;
  39.     FVisible: Boolean;
  40.     FGroupIndex: Byte;
  41.     FBreak: TMenuBreak;
  42.     FCommand: Word;
  43.     FHelpContext: THelpContext;
  44.     FHint: string;
  45.     FItems: TList;
  46.     FShortCut: TShortCut;
  47.     FParent: TMenuItem;
  48.     FMerged: TMenuItem;
  49.     FMenu: TMenu;
  50.     FOnChange: TMenuChangeEvent;
  51.     FOnClick: TNotifyEvent;
  52.     procedure AppendTo(Menu: HMENU);
  53.     procedure ClearHandles;
  54.     procedure ReadShortCutText(Reader: TReader);
  55.     procedure MergeWith(Menu: TMenuItem);
  56.     procedure RebuildHandle;
  57.     procedure PopulateMenu;
  58.     procedure SubItemChanged(Sender: TObject; Rebuild: Boolean);
  59.     procedure TurnSiblingsOff;
  60.     procedure WriteShortCutText(Writer: TWriter);
  61.     procedure VerifyGroupIndex(Position: Integer; Value: Byte);
  62.   protected
  63.     procedure DefineProperties(Filer: TFiler); override;
  64.     function GetHandle: HMENU;
  65.     function GetCount: Integer;
  66.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  67.     function GetItem(Index: Integer): TMenuItem;
  68.     function GetMenuIndex: Integer;
  69.     function GetParentComponent: TComponent; override;
  70.     procedure MenuChanged(Rebuild: Boolean); virtual;
  71.     function HasParent: Boolean; override;
  72.     procedure SetBreak(Value: TMenuBreak);
  73.     procedure SetCaption(const Value: string);
  74.     procedure SetChecked(Value: Boolean);
  75.     procedure SetChildOrder(Child: TComponent; Order: Integer); override;
  76.     procedure SetDefault(Value: Boolean);
  77.     procedure SetEnabled(Value: Boolean);
  78.     procedure SetGroupIndex(Value: Byte);
  79.     procedure SetMenuIndex(Value: Integer);
  80.     procedure SetParentComponent(Value: TComponent); override;
  81.     procedure SetRadioItem(Value: Boolean);
  82.     procedure SetShortCut(Value: TShortCut);
  83.     procedure SetVisible(Value: Boolean);
  84.   public
  85.     constructor Create(AOwner: TComponent); override;
  86.     destructor Destroy; override;
  87.     procedure Insert(Index: Integer; Item: TMenuItem);
  88.     procedure Delete(Index: Integer);
  89.     procedure Click; virtual;
  90.     function IndexOf(Item: TMenuItem): Integer;
  91.     procedure Add(Item: TMenuItem);
  92.     procedure Remove(Item: TMenuItem);
  93.     property Command: Word read FCommand;
  94.     property Handle: HMENU read GetHandle;
  95.     property Count: Integer read GetCount;
  96.     property Items[Index: Integer]: TMenuItem read GetItem; default;
  97.     property MenuIndex: Integer read GetMenuIndex write SetMenuIndex;
  98.     property Parent: TMenuItem read FParent;
  99.   published
  100.     property Break: TMenuBreak read FBreak write SetBreak default mbNone;
  101.     property Caption: string read FCaption write SetCaption;
  102.     property Checked: Boolean read FChecked write SetChecked default False;
  103.     property Default: Boolean read FDefault write SetDefault default False;
  104.     property Enabled: Boolean read FEnabled write SetEnabled default True;
  105.     property GroupIndex: Byte read FGroupIndex write SetGroupIndex default 0;
  106.     property HelpContext: THelpContext read FHelpContext write FHelpContext default 0;
  107.     property Hint: string read FHint write FHint;
  108.     property RadioItem: Boolean read FRadioItem write SetRadioItem default False;
  109.     property ShortCut: TShortCut read FShortCut write SetShortCut default 0;
  110.     property Visible: Boolean read FVisible write SetVisible default True;
  111.     property OnClick: TNotifyEvent read FOnClick write FOnClick;
  112.   end;
  113.  
  114.   TFindItemKind = (fkCommand, fkHandle, fkShortCut);
  115.  
  116.   TMenu = class(TComponent)
  117.   private
  118.     FItems: TMenuItem;
  119.     FWindowHandle: HWND;
  120.     FMenuImage: string;
  121.     procedure MenuChanged(Sender: TObject; Rebuild: Boolean); virtual;
  122.     procedure SetWindowHandle(Value: HWND);
  123.     function UpdateImage: Boolean;
  124.   protected
  125.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  126.     function GetHandle: HMENU; virtual;
  127.     procedure SetChildOrder(Child: TComponent; Order: Integer); override;
  128.   public
  129.     constructor Create(AOwner: TComponent); override;
  130.     destructor Destroy; override;
  131.     function DispatchCommand(ACommand: Word): Boolean;
  132.     function DispatchPopup(AHandle: HMENU): Boolean;
  133.     function FindItem(Value: Integer; Kind: TFindItemKind): TMenuItem;
  134.     function GetHelpContext(Value: Word; ByCommand: Boolean): THelpContext;
  135.     function IsShortCut(var Message: TWMKey): Boolean;
  136.     property Handle: HMENU read GetHandle;
  137.     property WindowHandle: HWND read FWindowHandle write SetWindowHandle;
  138.   published
  139.     property Items: TMenuItem read FItems;
  140.   end;
  141.  
  142.   TMainMenu = class(TMenu)
  143.   private
  144.     FOle2Menu: HMENU;
  145.     FAutoMerge: Boolean;
  146.     procedure ItemChanged;
  147.     procedure MenuChanged(Sender: TObject; Rebuild: Boolean); override;
  148.     procedure SetAutoMerge(Value: Boolean);
  149.   protected
  150.     function GetHandle: HMENU; override;
  151.   public
  152.     procedure Merge(Menu: TMainMenu);
  153.     procedure Unmerge(Menu: TMainMenu);
  154.     procedure PopulateOle2Menu(SharedMenu: HMenu; Groups: array of Integer;
  155.       var Widths: array of Longint);
  156.     procedure GetOle2AcceleratorTable(var AccelTable: HAccel;
  157.       var AccelCount: Integer; Groups: array of Integer);
  158.     procedure SetOle2MenuHandle(Handle: HMENU);
  159.   published
  160.     property AutoMerge: Boolean read FAutoMerge write SetAutoMerge default False;
  161.   end;
  162.  
  163.   TPopupAlignment = (paLeft, paRight, paCenter);
  164.  
  165.   TPopupMenu = class(TMenu)
  166.   private
  167.     FAlignment: TPopupAlignment;
  168.     FAutoPopup: Boolean;
  169.     FPopupComponent: TComponent;
  170.     FOnPopup: TNotifyEvent;
  171.     procedure DoPopup(Item: TObject);
  172.     function GetHelpContext: THelpContext;
  173.     procedure SetHelpContext(Value: THelpContext);
  174.   public
  175.     constructor Create(AOwner: TComponent); override;
  176.     destructor Destroy; override;
  177.     procedure Popup(X, Y: Integer); virtual;
  178.     property PopupComponent: TComponent read FPopupComponent write FPopupComponent;
  179.   published
  180.     property Alignment: TPopupAlignment read FAlignment write FAlignment default paLeft;
  181.     property AutoPopup: Boolean read FAutoPopup write FAutoPopup default True;
  182.     property HelpContext: THelpContext read GetHelpContext write SetHelpContext default 0;
  183.     property OnPopup: TNotifyEvent read FOnPopup write FOnPopup;
  184.   end;
  185.  
  186. function ShortCut(Key: Word; Shift: TShiftState): TShortCut;
  187. procedure ShortCutToKey(ShortCut: TShortCut; var Key: Word; var Shift: TShiftState);
  188. function ShortCutToText(ShortCut: TShortCut): string;
  189. function TextToShortCut(Text: string): TShortCut;
  190.  
  191. function NewMenu(Owner: TComponent; const AName: string; Items: array of TMenuItem): TMainMenu;
  192. function NewPopupMenu(Owner: TComponent; const AName: string;
  193.   Alignment: TPopupAlignment; AutoPopup: Boolean; Items: array of TMenuitem): TPopupMenu;
  194. function NewSubMenu(const ACaption: string; hCtx: Word; const AName: string;
  195.   Items: array of TMenuItem): TMenuItem;
  196. function NewItem(const ACaption: string; AShortCut: TShortCut;
  197.   AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: Word;
  198.   const AName: string): TMenuItem;
  199. function NewLine: TMenuItem;
  200.  
  201. implementation
  202.  
  203. uses Controls, Forms, Consts;
  204.  
  205. procedure Error(const S: string);
  206. begin
  207.   raise EMenuError.Create(S);
  208. end;
  209.  
  210. procedure IndexError;
  211. begin
  212.   Error(SMenuIndexError);
  213. end;
  214.  
  215. { TShortCut processing routines }
  216.  
  217. function ShortCut(Key: Word; Shift: TShiftState): TShortCut;
  218. begin
  219.   Result := 0;
  220.   if WordRec(Key).Hi <> 0 then Exit;
  221.   Result := Key;
  222.   if ssShift in Shift then Inc(Result, scShift);
  223.   if ssCtrl in Shift then Inc(Result, scCtrl);
  224.   if ssAlt in Shift then Inc(Result, scAlt);
  225. end;
  226.  
  227. procedure ShortCutToKey(ShortCut: TShortCut; var Key: Word; var Shift: TShiftState);
  228. begin
  229.   Key := ShortCut and not (scShift + scCtrl + scAlt);
  230.   Shift := [];
  231.   if ShortCut and scShift <> 0 then Include(Shift, ssShift);
  232.   if ShortCut and scCtrl <> 0 then Include(Shift, ssCtrl);
  233.   if ShortCut and scAlt <> 0 then Include(Shift, ssAlt);
  234. end;
  235.  
  236. type
  237.   TMenuKeyCap = (mkcBkSp, mkcTab, mkcEsc, mkcEnter, mkcSpace, mkcPgUp,
  238.     mkcPgDn, mkcEnd, mkcHome, mkcLeft, mkcUp, mkcRight, mkcDown, mkcIns,
  239.     mkcDel, mkcShift, mkcCtrl, mkcAlt);
  240.  
  241. var
  242.   MenuKeyCaps: array[TMenuKeyCap] of string = (
  243.     SmkcBkSp, SmkcTab, SmkcEsc, SmkcEnter, SmkcSpace, SmkcPgUp,
  244.     SmkcPgDn, SmkcEnd, SmkcHome, SmkcLeft, SmkcUp, SmkcRight,
  245.     SmkcDown, SmkcIns, SmkcDel, SmkcShift, SmkcCtrl, SmkcAlt);
  246.  
  247. function GetSpecialName(ShortCut: TShortCut): string;
  248. var
  249.   ScanCode: Integer;
  250.   KeyName: array[0..255] of Char;
  251. begin
  252.   Result := '';
  253.   ScanCode := MapVirtualKey(WordRec(ShortCut).Lo, 0) shl 16;
  254.   if ScanCode <> 0 then
  255.   begin
  256.     GetKeyNameText(ScanCode, KeyName, SizeOf(KeyName));
  257.     if (KeyName[1] = #0) and (KeyName[0] <> #0) then
  258.       GetSpecialName := KeyName;
  259.   end;
  260. end;
  261.  
  262. function ShortCutToText(ShortCut: TShortCut): string;
  263. var
  264.   Name: string;
  265. begin
  266.   case WordRec(ShortCut).Lo of
  267.     $08, $09:
  268.       Name := MenuKeyCaps[TMenuKeyCap(Ord(mkcBkSp) + WordRec(ShortCut).Lo - $08)];
  269.     $0D: Name := MenuKeyCaps[mkcEnter];
  270.     $1B: Name := MenuKeyCaps[mkcEsc];
  271.     $20..$28:
  272.       Name := MenuKeyCaps[TMenuKeyCap(Ord(mkcSpace) + WordRec(ShortCut).Lo - $20)];
  273.     $2D..$2E:
  274.       Name := MenuKeyCaps[TMenuKeyCap(Ord(mkcIns) + WordRec(ShortCut).Lo - $2D)];
  275.     $30..$39: Name := Chr(WordRec(ShortCut).Lo - $30 + Ord('0'));
  276.     $41..$5A: Name := Chr(WordRec(ShortCut).Lo - $41 + Ord('A'));
  277.     $60..$69: Name := Chr(WordRec(ShortCut).Lo - $60 + Ord('0'));
  278.     $70..$87: Name := 'F' + IntToStr(WordRec(ShortCut).Lo - $6F);
  279.   else
  280.     Name := GetSpecialName(ShortCut);
  281.   end;
  282.   if Name <> '' then
  283.   begin
  284.     Result := '';
  285.     if ShortCut and scShift <> 0 then Result := Result + MenuKeyCaps[mkcShift];
  286.     if ShortCut and scCtrl <> 0 then Result := Result + MenuKeyCaps[mkcCtrl];
  287.     if ShortCut and scAlt <> 0 then Result := Result + MenuKeyCaps[mkcAlt];
  288.     Result := Result + Name;
  289.   end
  290.   else Result := '';
  291. end;
  292.  
  293. { This function is *very* slow.  Use sparingly.  Return 0 if no VK code was
  294.   found for the text }
  295.  
  296. function TextToShortCut(Text: string): TShortCut;
  297.  
  298.   { If the front of Text is equal to Front then remove the matching piece
  299.     from Text and return True, otherwise return False }
  300.  
  301.   function CompareFront(var Text: string; const Front: string): Boolean;
  302.   begin
  303.     Result := False;
  304.     if (Length(Text) >= Length(Front)) and
  305.       (AnsiStrLIComp(PChar(Text), PChar(Front), Length(Front)) = 0) then
  306.     begin
  307.       Result := True;
  308.       Delete(Text, 1, Length(Front));
  309.     end;
  310.   end;
  311.  
  312. var
  313.   Key: TShortCut;
  314.   Shift: TShortCut;
  315. begin
  316.   Result := 0;
  317.   Shift := 0;
  318.   while True do
  319.   begin
  320.     if CompareFront(Text, MenuKeyCaps[mkcShift]) then Shift := Shift or scShift
  321.     else if CompareFront(Text, '^') then Shift := Shift or scCtrl
  322.     else if CompareFront(Text, MenuKeyCaps[mkcCtrl]) then Shift := Shift or scCtrl
  323.     else if CompareFront(Text, MenuKeyCaps[mkcAlt]) then Shift := Shift or scAlt
  324.     else Break;
  325.   end;
  326.   if Text = '' then Exit;
  327.   for Key := $08 to $255 do { Copy range from table in ShortCutToText }
  328.     if AnsiCompareText(Text, ShortCutToText(Key)) = 0 then
  329.     begin
  330.       Result := Key or Shift;
  331.       Exit;
  332.     end;
  333. end;
  334.  
  335. { Menu command managment }
  336.  
  337. var
  338.   CommandPool: TBits;
  339.  
  340. function UniqueCommand: Word;
  341. begin
  342.   Result := CommandPool.OpenBit;
  343.   CommandPool[Result] := True;
  344. end;
  345.  
  346. { Used to populate or merge menus }
  347.  
  348. procedure IterateMenus(Func: Pointer; Menu1, Menu2: TMenuItem);
  349. var
  350.   I, J: Integer;
  351.   IIndex, JIndex: Byte;
  352.   Menu1Size, Menu2Size: Integer;
  353.   Done: Boolean;
  354.  
  355.   function Iterate(var I: Integer; MenuItem: TMenuItem; AFunc: Pointer): Boolean;
  356.   var
  357.     Item: TMenuItem;
  358.   begin
  359.     if MenuItem = nil then Exit;
  360.     Result := False;
  361.     while not Result and (I < MenuItem.Count) do
  362.     begin
  363.       Item := MenuItem[I];
  364.       if Item.GroupIndex > IIndex then Break;
  365.       asm
  366.                 MOV     EAX,Item
  367.                 MOV     EDX,[EBP+8]
  368.                 PUSH    DWORD PTR [EDX]
  369.                 CALL    DWORD PTR AFunc
  370.                 ADD     ESP,4
  371.                 MOV     Result,AL
  372.       end;
  373.       Inc(I);
  374.     end;
  375.   end;
  376.  
  377. begin
  378.   I := 0;
  379.   J := 0;
  380.   Menu1Size := 0;
  381.   Menu2Size := 0;
  382.   if Menu1 <> nil then Menu1Size := Menu1.Count;
  383.   if Menu2 <> nil then Menu2Size := Menu2.Count;
  384.   Done := False;
  385.   while not Done and ((I < Menu1Size) or (J < Menu2Size)) do
  386.   begin
  387.     IIndex := High(Byte);
  388.     JIndex := High(Byte);
  389.     if (I < Menu1Size) then IIndex := Menu1[I].GroupIndex;
  390.     if (J < Menu2Size) then JIndex := Menu2[J].GroupIndex;
  391.     if IIndex <= JIndex then Done := Iterate(I, Menu1, Func)
  392.     else
  393.     begin
  394.       IIndex := JIndex;
  395.       Done := Iterate(J, Menu2, Func);
  396.     end;
  397.     while (I < Menu1Size) and (Menu1[I].GroupIndex <= IIndex) do Inc(I);
  398.     while (J < Menu2Size) and (Menu2[J].GroupIndex <= IIndex) do Inc(J);
  399.   end;
  400. end;
  401.  
  402. { TMenuItem }
  403.  
  404. constructor TMenuItem.Create(AOwner: TComponent);
  405. begin
  406.   inherited Create(AOwner);
  407.   FVisible := True;
  408.   FEnabled := True;
  409.   FCommand := UniqueCommand;
  410. end;
  411.  
  412. destructor TMenuItem.Destroy;
  413. begin
  414.   if FParent <> nil then
  415.   begin
  416.     FParent.Remove(Self);
  417.     FParent := nil;
  418.   end;
  419.   if FHandle <> 0 then
  420.   begin
  421.     MergeWith(nil);
  422.     DestroyMenu(FHandle);
  423.     ClearHandles;
  424.   end;
  425.   while Count > 0 do Items[0].Free;
  426.   FItems.Free;
  427.   if FCommand <> 0 then CommandPool[FCommand] := False;
  428.   inherited Destroy;
  429. end;
  430.  
  431. procedure TMenuItem.ClearHandles;
  432.  
  433.   procedure Clear(Item: TMenuItem);
  434.   var
  435.     I: Integer;
  436.   begin
  437.     with Item do
  438.     begin
  439.       FHandle := 0;
  440.       for I := 0 to GetCount - 1 do Clear(FItems[I]);
  441.     end;
  442.   end;
  443.  
  444. begin
  445.   Clear(Self);
  446. end;
  447.  
  448. const
  449.   Checks: array[Boolean] of LongInt = (MF_UNCHECKED, MF_CHECKED);
  450.   Enables: array[Boolean] of LongInt = (MF_DISABLED or MF_GRAYED, MF_ENABLED);
  451.   Breaks: array[TMenuBreak] of Longint = (0, MF_MENUBREAK, MF_MENUBARBREAK);
  452.   Separators: array[Boolean] of LongInt = (MF_STRING, MF_SEPARATOR);
  453.  
  454. procedure TMenuItem.AppendTo(Menu: HMENU);
  455. const
  456.   IBreaks: array[TMenuBreak] of Longint = (MFT_STRING, MFT_MENUBREAK, MFT_MENUBARBREAK);
  457.   IChecks: array[Boolean] of Longint = (MFS_UNCHECKED, MFS_CHECKED);
  458.   IDefaults: array[Boolean] of Longint = (0, MFS_DEFAULT);
  459.   IEnables: array[Boolean] of Longint = (MFS_DISABLED or MFS_GRAYED, MFS_ENABLED);
  460.   IRadios: array[Boolean] of Longint = (MFT_STRING, MFT_RADIOCHECK);
  461.   ISeparators: array[Boolean] of Longint = (MFT_STRING, MFT_SEPARATOR);
  462. var
  463.   MenuItemInfo: TMenuItemInfo;
  464.   Caption: string;
  465.   NewFlags: Integer;
  466. begin
  467.   if FVisible then
  468.   begin
  469.     Caption := FCaption;
  470.     if GetCount > 0 then MenuItemInfo.hSubMenu := GetHandle
  471.     else if (FShortCut <> scNone) and ((Parent = nil) or
  472.       (Parent.Parent <> nil) or not (Parent.Owner is TMainMenu)) then
  473.       Caption := Caption + #9 + ShortCutToText(FShortCut);
  474.     if Lo(GetVersion) >= 4 then
  475.     begin
  476.       MenuItemInfo.cbSize := SizeOf(TMenuItemInfo);
  477.       MenuItemInfo.fMask := MIIM_CHECKMARKS or MIIM_DATA or MIIM_ID or
  478.         MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;
  479.       MenuItemInfo.fType := IRadios[FRadioItem] or IBreaks[FBreak] or
  480.         ISeparators[FCaption = '-'];
  481.       MenuItemInfo.fState := IChecks[FChecked] or IEnables[FEnabled]
  482.         or IDefaults[FDefault];
  483.       MenuItemInfo.wID := Command;
  484.       MenuItemInfo.hSubMenu := 0;
  485.       MenuItemInfo.hbmpChecked := 0;
  486.       MenuItemInfo.hbmpUnchecked := 0;
  487.       MenuItemInfo.dwTypeData := PChar(Caption);
  488.       if GetCount > 0 then MenuITemInfo.hSubMenu := GetHandle;
  489.       InsertMenuItem(Menu, -1, True, MenuItemInfo);
  490.     end
  491.     else
  492.     begin
  493.       NewFlags := Breaks[FBreak] or Checks[FChecked] or Enables[FEnabled] or
  494.         Separators[FCaption = '-'] or MF_BYPOSITION;
  495.       if GetCount > 0 then
  496.         InsertMenu(Menu, -1, MF_POPUP or NewFlags, GetHandle,
  497.           PChar(FCaption))
  498.       else
  499.         InsertMenu(Menu, -1, NewFlags, Command, PChar(Caption));
  500.     end;
  501.   end;
  502. end;
  503.  
  504. procedure TMenuItem.PopulateMenu;
  505.  
  506.   function AddIn(MenuItem: TMenuItem): Boolean;
  507.   begin
  508.     MenuItem.AppendTo(FHandle);
  509.     Result := False;
  510.   end;
  511.  
  512. begin
  513.   IterateMenus(@AddIn, FMerged, Self);
  514. end;
  515.  
  516. procedure TMenuItem.ReadShortCutText(Reader: TReader);
  517. begin
  518.   ShortCut := TextToShortCut(Reader.ReadString);
  519. end;
  520.  
  521. procedure TMenuItem.MergeWith(Menu: TMenuItem);
  522. begin
  523.   if FMerged <> Menu then
  524.   begin
  525.     FMerged := Menu;
  526.     RebuildHandle;
  527.   end;
  528. end;
  529.  
  530. procedure TMenuItem.RebuildHandle;
  531. begin
  532.   while GetMenuItemCount(Handle) > 0 do RemoveMenu(Handle, 0, MF_BYPOSITION);
  533.   PopulateMenu;
  534.   MenuChanged(False);
  535. end;
  536.  
  537. procedure TMenuItem.VerifyGroupIndex(Position: Integer; Value: Byte);
  538. var
  539.   I: Integer;
  540. begin
  541.   for I := 0 to GetCount - 1 do
  542.     if I < Position then
  543.     begin
  544.       if Items[I].GroupIndex > Value then Error(SGroupIndexTooLow)
  545.     end
  546.     else
  547.       { Ripple change to menu items at Position and after }
  548.       if Items[I].GroupIndex < Value then Items[I].FGroupIndex := Value;
  549. end;
  550.  
  551. procedure TMenuItem.WriteShortCutText(Writer: TWriter);
  552. begin
  553.   {Writer.WriteString(ShortCutToText(ShortCut));}
  554. end;
  555.  
  556. function TMenuItem.GetHandle: HMENU;
  557. begin
  558.   if FHandle = 0 then
  559.   begin
  560.     if Owner is TPopupMenu then
  561.       FHandle := CreatePopupMenu
  562.     else
  563.       FHandle := CreateMenu;
  564.     if FHandle = 0 then raise EMenuError.Create(SOutOfResources);
  565.     PopulateMenu;
  566.   end;
  567.   Result := FHandle;
  568. end;
  569.  
  570. procedure TMenuItem.DefineProperties(Filer: TFiler);
  571. begin
  572.   inherited DefineProperties(Filer);
  573.   Filer.DefineProperty('ShortCutText', ReadShortCutText, WriteShortCutText, False);
  574. end;
  575.  
  576. function TMenuItem.HasParent: Boolean;
  577. begin
  578.   Result := True;
  579. end;
  580.  
  581. procedure TMenuItem.SetBreak(Value: TMenuBreak);
  582. begin
  583.   if FBreak <> Value then
  584.   begin
  585.     FBreak := Value;
  586.     MenuChanged(True);
  587.   end;
  588. end;
  589.  
  590. procedure TMenuItem.SetCaption(const Value: string);
  591. begin
  592.   if FCaption <> Value then
  593.   begin
  594.     FCaption := Value;
  595.     MenuChanged(True);
  596.   end;
  597. end;
  598.  
  599. procedure TMenuItem.TurnSiblingsOff;
  600. var
  601.   I: Integer;
  602.   Item: TMenuItem;
  603. begin
  604.   if FParent <> nil then
  605.     for I := 0 to FParent.Count - 1 do
  606.     begin
  607.       Item := FParent[I];
  608.       if (Item <> Self) and Item.FRadioItem and (Item.GroupIndex = GroupIndex) then
  609.         Item.SetChecked(False);
  610.     end;
  611. end;
  612.   
  613. procedure TMenuItem.SetChecked(Value: Boolean);
  614.  
  615. begin
  616.   if FChecked <> Value then
  617.   begin
  618.     FChecked := Value;
  619.     if FParent <> nil then
  620.       CheckMenuItem(FParent.Handle, FCommand, MF_BYCOMMAND or Checks[Value]);
  621.     if Value and FRadioItem then
  622.       TurnSiblingsOff;
  623.   end;
  624. end;
  625.  
  626. procedure TMenuItem.SetEnabled(Value: Boolean);
  627. begin
  628.   if FEnabled <> Value then
  629.   begin
  630.     FEnabled := Value;
  631.     if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Count <> 0) then
  632.       MenuChanged(True)
  633.     else
  634.     begin
  635.       if FParent <> nil then
  636.         EnableMenuItem(FParent.Handle, FCommand, MF_BYCOMMAND or Enables[Value]);
  637.       MenuChanged(False);
  638.     end;
  639.   end;
  640. end;
  641.  
  642. procedure TMenuItem.SetGroupIndex(Value: Byte);
  643. begin
  644.   if FGroupIndex <> Value then
  645.   begin
  646.     if Parent <> nil then Parent.VerifyGroupIndex(Parent.IndexOf(Self), Value);
  647.     FGroupIndex := Value;
  648.     if FChecked and FRadioItem then
  649.       TurnSiblingsOff;
  650.   end;
  651. end;
  652.  
  653. function TMenuItem.GetCount: Integer;
  654. begin
  655.   if FItems = nil then Result := 0
  656.   else Result := FItems.Count;
  657. end;
  658.  
  659. function TMenuItem.GetItem(Index: Integer): TMenuItem;
  660. begin
  661.   if FItems = nil then IndexError;
  662.   Result := FItems[Index];
  663. end;
  664.  
  665. procedure TMenuItem.SetShortCut(Value: TShortCut);
  666. begin
  667.   FShortCut := Value;
  668.   MenuChanged(True);
  669. end;
  670.  
  671. procedure TMenuItem.SetVisible(Value: Boolean);
  672. begin
  673.   FVisible := Value;
  674.   MenuChanged(True);
  675. end;
  676.  
  677. function TMenuItem.GetMenuIndex: Integer;
  678. begin
  679.   Result := -1;
  680.   if FParent <> nil then Result := FParent.IndexOf(Self);
  681. end;
  682.  
  683. procedure TMenuItem.SetMenuIndex(Value: Integer);
  684. var
  685.   Parent: TMenuItem;
  686.   Count: Integer;
  687. begin
  688.   if FParent <> nil then
  689.   begin
  690.     Count := FParent.Count;
  691.     if Value < 0 then Value := 0;
  692.     if Value >= Count then Value := Count - 1;
  693.     if Value <> MenuIndex then
  694.     begin
  695.       Parent := FParent;
  696.       Parent.Remove(Self);
  697.       Parent.Insert(Value, Self);
  698.     end;
  699.   end;
  700. end;
  701.  
  702. procedure TMenuItem.GetChildren(Proc: TGetChildProc; Root: TComponent);
  703. var
  704.   I: Integer;
  705. begin
  706.   for I := 0 to Count - 1 do Proc(Items[I]);
  707. end;
  708.  
  709. procedure TMenuItem.SetChildOrder(Child: TComponent; Order: Integer);
  710. begin
  711.   (Child as TMenuItem).MenuIndex := Order;
  712. end;
  713.  
  714. procedure TMenuItem.SetDefault(Value: Boolean);
  715. var
  716.   I: Integer;
  717. begin
  718.   if FDefault <> Value then
  719.   begin
  720.     if Value and (FParent <> nil) then
  721.       for I := 0 to FParent.Count - 1 do
  722.         if FParent[I].Default then FParent[I].FDefault := False; 
  723.     FDefault := Value;
  724.     MenuChanged(True);
  725.   end;
  726. end;
  727.  
  728. procedure TMenuItem.Insert(Index: Integer; Item: TMenuItem);
  729. begin
  730.   if Item.FParent <> nil then
  731.     raise EMenuError.Create(SMenuReinserted);
  732.   if FItems = nil then FItems := TList.Create;
  733.   if (Index - 1 >= 0) and (Index - 1 < FItems.Count) then
  734.     if Item.GroupIndex < TMenuItem(FItems[Index - 1]).GroupIndex then
  735.       Item.GroupIndex := TMenuItem(FItems[Index - 1]).GroupIndex;
  736.   VerifyGroupIndex(Index, Item.GroupIndex);
  737.   FItems.Insert(Index, Item);
  738.   Item.FParent := Self;
  739.   Item.FOnChange := SubItemChanged;
  740.   if FHandle <> 0 then RebuildHandle;
  741.   MenuChanged(Count = 1);
  742. end;
  743.  
  744. procedure TMenuItem.Delete(Index: Integer);
  745. var
  746.   Cur: TMenuItem;
  747. begin
  748.   if (Index < 0) or (FItems = nil) or (Index >= GetCount) then IndexError;
  749.   Cur := FItems[Index];
  750.   FItems.Delete(Index);
  751.   Cur.FParent := nil;
  752.   Cur.FOnChange := nil;
  753.   if FHandle <> 0 then RebuildHandle;
  754.   MenuChanged(Count = 0);
  755. end;
  756.  
  757. procedure TMenuItem.Click;
  758. begin
  759.   if FEnabled and Assigned(FOnClick) then FOnClick(Self);
  760. end;
  761.  
  762. function TMenuItem.IndexOf(Item: TMenuItem): Integer;
  763. begin
  764.   Result := -1;
  765.   if FItems <> nil then Result := FItems.IndexOf(Item);
  766. end;
  767.  
  768. procedure TMenuItem.Add(Item: TMenuItem);
  769. begin
  770.   Insert(GetCount, Item);
  771. end;
  772.  
  773. procedure TMenuItem.Remove(Item: TMenuItem);
  774. var
  775.   I: Integer;
  776. begin
  777.   I := IndexOf(Item);
  778.   if I = -1 then raise EMenuError.Create(SMenuNotFound);
  779.   Delete(I);
  780. end;
  781.  
  782. procedure TMenuItem.MenuChanged(Rebuild: Boolean);
  783. begin
  784.   if Assigned(FOnChange) then FOnChange(Self, Rebuild);
  785. end;
  786.  
  787. procedure TMenuItem.SubItemChanged(Sender: TObject; Rebuild: Boolean);
  788. begin
  789.   if Rebuild and (FHandle <> 0) then RebuildHandle;
  790.   if Parent <> nil then Parent.SubItemChanged(Self, False)
  791.   else if Owner is TMainMenu then TMainMenu(Owner).ItemChanged;
  792. end;
  793.  
  794. function TMenuItem.GetParentComponent: TComponent;
  795. begin
  796.   if (FParent <> nil) and (FParent.FMenu <> nil) then
  797.     Result := FParent.FMenu else
  798.     Result := FParent;
  799. end;
  800.  
  801. procedure TMenuItem.SetParentComponent(Value: TComponent);
  802. begin
  803.   if FParent <> nil then FParent.Remove(Self);
  804.   if Value <> nil then
  805.     if Value is TMenu then
  806.       TMenu(Value).Items.Add(Self)
  807.     else if Value is TMenuItem then
  808.       TMenuItem(Value).Add(Self);
  809. end;
  810.  
  811. procedure TMenuItem.SetRadioItem(Value: Boolean);
  812. begin
  813.   if FRadioItem <> Value then
  814.   begin
  815.     FRadioItem := Value;
  816.     if FChecked and FRadioItem then
  817.       TurnSiblingsOff;
  818.     MenuChanged(True);
  819.   end;
  820. end;
  821.  
  822. { TMenu }
  823.  
  824. constructor TMenu.Create(AOwner: TComponent);
  825. begin
  826.   FItems := TMenuItem.Create(Self);
  827.   FItems.FOnChange := MenuChanged;
  828.   FItems.FMenu := Self;
  829.   inherited Create(AOwner);
  830. end;
  831.  
  832. destructor TMenu.Destroy;
  833. begin
  834.   FItems.Free;
  835.   inherited Destroy;
  836. end;
  837.  
  838. procedure TMenu.GetChildren(Proc: TGetChildProc; Root: TComponent);
  839. begin
  840.   FItems.GetChildren(Proc, Root);
  841. end;
  842.  
  843. function TMenu.GetHandle: HMENU;
  844. begin
  845.   Result := FItems.GetHandle;
  846. end;
  847.  
  848. procedure TMenu.SetChildOrder(Child: TComponent; Order: Integer);
  849. begin
  850.   FItems.SetChildOrder(Child, Order);
  851. end;
  852.  
  853. function TMenu.FindItem(Value: Integer; Kind: TFindItemKind): TMenuItem;
  854. var
  855.   FoundItem: TMenuItem;
  856.  
  857.   function Find(Item: TMenuItem): Boolean;
  858.   var
  859.     I: Integer;
  860.   begin
  861.     Result := False;
  862.     if ((Kind = fkCommand) and (Value = Item.Command)) or
  863.       ((Kind = fkHandle) and (Value = Item.FHandle)) or
  864.       ((Kind = fkShortCut) and (Value = Item.ShortCut)) then
  865.     begin
  866.       FoundItem := Item;
  867.       Result := True;
  868.       Exit;
  869.     end
  870.     else
  871.       for I := 0 to Item.GetCount - 1 do
  872.         if Find(Item[I]) then
  873.         begin
  874.           Result := True;
  875.           Exit;
  876.         end;
  877.   end;
  878.  
  879. begin
  880.   FoundItem := nil;
  881.   IterateMenus(@Find, Items.FMerged, Items);
  882.   Result := FoundItem;
  883. end;
  884.  
  885. function TMenu.GetHelpContext(Value: Word; ByCommand: Boolean): THelpContext;
  886. var
  887.   Item: TMenuItem;
  888.   Kind: TFindItemKind;
  889. begin
  890.   Result := 0;
  891.   Kind := fkHandle;
  892.   if ByCommand then Kind := fkCommand;
  893.   Item := FindItem(Value, Kind);
  894.   while (Item <> nil) and (Item.FHelpContext = 0) do
  895.     Item := Item.FParent;
  896.   if Item <> nil then Result := Item.FHelpContext;
  897. end;
  898.  
  899. function TMenu.DispatchCommand(ACommand: Word): Boolean;
  900. var
  901.   Item: TMenuItem;
  902. begin
  903.   Result := False;
  904.   Item := FindItem(ACommand, fkCommand);
  905.   if Item <> nil then
  906.   begin
  907.     Item.Click;
  908.     Result := True;
  909.   end;
  910. end;
  911.  
  912. function TMenu.DispatchPopup(AHandle: HMENU): Boolean;
  913. var
  914.   Item: TMenuItem;
  915. begin
  916.   Result := False;
  917.   Item := FindItem(AHandle, fkHandle);
  918.   if Item <> nil then
  919.   begin
  920.     Item.Click;
  921.     Result := True;
  922.   end;
  923. end;
  924.  
  925. function TMenu.IsShortCut(var Message: TWMKey): Boolean;
  926. type
  927.   TClickResult = (crDisabled, crClicked, crShortCutMoved);
  928. const
  929.   AltMask = $20000000;
  930. var
  931.   ShortCut: TShortCut;
  932.   ShortCutItem: TMenuItem;
  933.   ClickResult: TClickResult;
  934.  
  935.   function DoClick(Item: TMenuItem): TClickResult;
  936.   begin
  937.     Result := crClicked;
  938.     if Item.Parent <> nil then Result := DoClick(Item.Parent);
  939.     if Result = crClicked then
  940.       if Item.Enabled then
  941.         try
  942.           Item.Click;
  943.           if ShortCutItem.ShortCut <> ShortCut then
  944.             Result := crShortCutMoved;
  945.         except
  946.           Application.HandleException(Self);
  947.         end
  948.       else Result := crDisabled;
  949.   end;
  950.  
  951. begin
  952.   Result := False;
  953.   if FWindowHandle <> 0 then
  954.   begin
  955.     ShortCut := Byte(Message.CharCode);
  956.     if GetKeyState(VK_SHIFT) < 0 then Inc(ShortCut, scShift);
  957.     if GetKeyState(VK_CONTROL) < 0 then Inc(ShortCut, scCtrl);
  958.     if Message.KeyData and AltMask <> 0 then Inc(ShortCut, scAlt);
  959.     repeat
  960.       ClickResult := crDisabled;
  961.       ShortCutItem := FindItem(ShortCut, fkShortCut);
  962.       if ShortCutItem <> nil then ClickResult := DoClick(ShortCutItem);
  963.     until ClickResult <> crShortCutMoved;
  964.     Result := ShortCutItem <> nil;
  965.   end;
  966. end;
  967.  
  968. function TMenu.UpdateImage: Boolean;
  969. var
  970.   Image: array[0..511] of Char;
  971.  
  972.   procedure BuildImage(Menu: HMENU);
  973.   var
  974.     P, ImageEnd: PChar;
  975.     I, C: Integer;
  976.     State: Word;
  977.   begin
  978.     C := GetMenuItemCount(Menu);
  979.     P := Image;
  980.     ImageEnd := @Image[SizeOf(Image) - 5];
  981.     I := 0;
  982.     while (I < C) and (P < ImageEnd) do
  983.     begin
  984.       GetMenuString(Menu, I, P, ImageEnd - P, MF_BYPOSITION);
  985.       P := StrEnd(P);
  986.       State := GetMenuState(Menu, I, MF_BYPOSITION);
  987.       if State and MF_DISABLED <> 0 then P := StrECopy(P, '$');
  988.       if State and MF_MENUBREAK <> 0 then P := StrECopy(P, '@');
  989.       if State and MF_GRAYED <> 0 then P := StrECopy(P, '#');
  990.       P := StrECopy(P, ';');
  991.       Inc(I);
  992.     end;
  993.   end;
  994.  
  995. begin
  996.   Result := False;
  997.   Image[0] := #0;
  998.   if FWindowHandle <> 0 then BuildImage(Handle);
  999.   if (FMenuImage = '') or (StrComp(PChar(FMenuImage), Image) <> 0) then
  1000.   begin
  1001.     Result := True;
  1002.     FMenuImage := Image;
  1003.   end;
  1004. end;
  1005.  
  1006. procedure TMenu.SetWindowHandle(Value: HWND);
  1007. begin
  1008.   FWindowHandle := Value;
  1009.   UpdateImage;
  1010. end;
  1011.  
  1012. procedure TMenu.MenuChanged(Sender: TObject; Rebuild: Boolean);
  1013. begin
  1014. end;
  1015.  
  1016. { TMainMenu }
  1017.  
  1018. procedure TMainMenu.SetAutoMerge(Value: Boolean);
  1019. begin
  1020.   if FAutoMerge <> Value then
  1021.   begin
  1022.     FAutoMerge := Value;
  1023.     if FWindowHandle <> 0 then
  1024.       SendMessage(FWindowHandle, CM_MENUCHANGED, 0, 0);
  1025.   end;
  1026. end;
  1027.  
  1028. procedure TMainMenu.MenuChanged(Sender: TObject; Rebuild: Boolean);
  1029. begin
  1030.   if (FWindowHandle <> 0) and UpdateImage then DrawMenuBar(FWindowHandle);
  1031. end;
  1032.  
  1033. procedure TMainMenu.Merge(Menu: TMainMenu);
  1034. begin
  1035.   if Menu <> nil then
  1036.     FItems.MergeWith(Menu.FItems) else
  1037.     FItems.MergeWith(nil);
  1038. end;
  1039.  
  1040. procedure TMainMenu.Unmerge(Menu: TMainMenu);
  1041. begin
  1042.   if (Menu <> nil) and (FItems.FMerged = Menu.FItems) then
  1043.     FItems.MergeWith(nil);
  1044. end;
  1045.  
  1046. procedure TMainMenu.ItemChanged;
  1047. begin
  1048.   MenuChanged(nil, False);
  1049.   if FWindowHandle <> 0 then
  1050.     SendMessage(FWindowHandle, CM_MENUCHANGED, 0, 0);
  1051. end;
  1052.  
  1053. function TMainMenu.GetHandle: HMENU;
  1054. begin
  1055.   if FOle2Menu <> 0 then
  1056.     Result := FOle2Menu else
  1057.     Result := inherited GetHandle;
  1058. end;
  1059.  
  1060. procedure TMainMenu.GetOle2AcceleratorTable(var AccelTable: HAccel;
  1061.   var AccelCount: Integer; Groups: array of Integer);
  1062. var
  1063.   NumAccels: Integer;
  1064.   AccelList, AccelPtr: PAccel;
  1065.  
  1066.   procedure ProcessAccels(Item: TMenuItem);
  1067.   var
  1068.     I: Integer;
  1069.     Virt: Byte;
  1070.   begin
  1071.     if Item.ShortCut <> 0 then
  1072.       if AccelPtr <> nil then
  1073.       begin
  1074.         Virt := FNOINVERT or FVIRTKEY;
  1075.         if Item.ShortCut and scCtrl <> 0 then Virt := Virt or FCONTROL;
  1076.         if Item.ShortCut and scAlt <> 0 then Virt := Virt or FALT;
  1077.         if Item.ShortCut and scShift <> 0 then Virt := Virt or FSHIFT;
  1078.         AccelPtr^.fVirt := Virt;
  1079.         AccelPtr^.key := Item.ShortCut and $FF;
  1080.         AccelPtr^.cmd := Item.Command;
  1081.         Inc(AccelPtr);
  1082.       end else
  1083.         Inc(NumAccels)
  1084.     else
  1085.       for I := 0 to Item.GetCount - 1 do ProcessAccels(Item[I]);
  1086.   end;
  1087.  
  1088.   function ProcessAccelItems(Item: TMenuItem): Boolean;
  1089.   var
  1090.     I: Integer;
  1091.   begin
  1092.     for I := 0 to High(Groups) do
  1093.       if Item.GroupIndex = Groups[I] then
  1094.       begin
  1095.         ProcessAccels(Item);
  1096.         Break;
  1097.       end;
  1098.     Result := False;
  1099.   end;
  1100.  
  1101. begin
  1102.   NumAccels := 0;
  1103.   AccelPtr := nil;
  1104.   IterateMenus(@ProcessAccelItems, Items.FMerged, Items);
  1105.   AccelTable := 0;
  1106.   if NumAccels <> 0 then
  1107.   begin
  1108.     GetMem(AccelList, NumAccels * SizeOf(TAccel));
  1109.     AccelPtr := AccelList;
  1110.     IterateMenus(@ProcessAccelItems, Items.FMerged, Items);
  1111.     AccelTable := CreateAcceleratorTable(AccelList^, NumAccels);
  1112.     FreeMem(AccelList);
  1113.   end;
  1114.   AccelCount := NumAccels;
  1115. end;
  1116.  
  1117. { Similar to regular TMenuItem.PopulateMenus except that it only adds
  1118.   the specified groups to the menu handle }
  1119.  
  1120. procedure TMainMenu.PopulateOle2Menu(SharedMenu: HMenu;
  1121.   Groups: array of Integer; var Widths: array of Longint);
  1122. var
  1123.   NumGroups: Integer;
  1124.   J: Integer;
  1125.  
  1126.   function AddOle2(Item: TMenuItem): Boolean;
  1127.   var
  1128.     I: Integer;
  1129.   begin
  1130.     for I := 0 to NumGroups do
  1131.     begin
  1132.       if Item.GroupIndex = Groups[I] then
  1133.       begin
  1134.         Inc(Widths[Item.GroupIndex]);
  1135.         Item.AppendTo(SharedMenu);
  1136.       end;
  1137.     end;
  1138.     Result := False;
  1139.   end;
  1140.  
  1141. begin
  1142.   NumGroups := High(Groups);
  1143.   for J := 0 to High(Widths) do Widths[J] := 0;
  1144.   IterateMenus(@AddOle2, Items.FMerged, Items);
  1145. end;
  1146.  
  1147. procedure TMainMenu.SetOle2MenuHandle(Handle: HMENU);
  1148. begin
  1149.   FOle2Menu := Handle;
  1150.   ItemChanged;
  1151. end;
  1152.  
  1153. { TPopupMenu }
  1154.  
  1155. type
  1156.   TPopupList = class(TList)
  1157.   private
  1158.     procedure WndProc(var Message: TMessage);
  1159.   public
  1160.     Window: HWND;
  1161.     procedure Add(Popup: TPopupMenu);
  1162.     procedure Remove(Popup: TPopupMenu);
  1163.   end;
  1164.  
  1165. var
  1166.   PopupList: TPopupList;
  1167.  
  1168. procedure TPopupList.WndProc(var Message: TMessage);
  1169. var
  1170.   I: Integer;
  1171.   MenuItem: TMenuItem;
  1172.   FindKind: TFindItemKind;
  1173.   ContextID: Integer;
  1174. begin
  1175.   try
  1176.     case Message.Msg of
  1177.       WM_COMMAND:
  1178.         for I := 0 to Count - 1 do
  1179.           if TPopupMenu(Items[I]).DispatchCommand(Message.wParam) then Exit;
  1180.       WM_INITMENUPOPUP:
  1181.         for I := 0 to Count - 1 do
  1182.           with TWMInitMenuPopup(Message) do
  1183.             if TPopupMenu(Items[I]).DispatchPopup(MenuPopup) then Exit;
  1184.       WM_MENUSELECT:
  1185.         with TWMMenuSelect(Message) do
  1186.         begin
  1187.           FindKind := fkCommand;
  1188.           if MenuFlag and MF_POPUP <> 0 then FindKind := fkHandle;
  1189.           for I := 0 to Count - 1 do
  1190.           begin
  1191.             MenuItem := TPopupMenu(Items[I]).FindItem(IDItem, FindKind);
  1192.             if MenuItem <> nil then
  1193.             begin
  1194.               Application.Hint := MenuItem.Hint;
  1195.               Exit;
  1196.             end;
  1197.           end;
  1198.           Application.Hint := '';
  1199.         end;
  1200.       WM_HELP:
  1201.         with PHelpInfo(Message.LParam)^ do
  1202.         begin
  1203.           for I := 0 to Count - 1 do
  1204.             if TPopupMenu(Items[I]).Handle = hItemHandle then
  1205.             begin
  1206.               ContextID := TMenu(Items[I]).GetHelpContext(iCtrlID, True);
  1207.               if ContextID = 0 then
  1208.                 ContextID := TMenu(Items[I]).GetHelpContext(hItemHandle, False);
  1209.               if Screen.ActiveForm = nil then Exit;
  1210.               if (biHelp in Screen.ActiveForm.BorderIcons) then
  1211.                 Application.HelpCommand(HELP_CONTEXTPOPUP, ContextID)
  1212.               else
  1213.                 Application.HelpContext(ContextID);
  1214.               Exit;
  1215.             end;
  1216.         end;
  1217.     end;
  1218.     with Message do Result := DefWindowProc(Window, Msg, wParam, lParam);
  1219.   except
  1220.     Application.HandleException(Self);
  1221.   end;
  1222. end;
  1223.  
  1224. procedure TPopupList.Add(Popup: TPopupMenu);
  1225. begin
  1226.   if Count = 0 then Window := AllocateHWnd(WndProc);
  1227.   inherited Add(Popup);
  1228. end;
  1229.  
  1230. procedure TPopupList.Remove(Popup: TPopupMenu);
  1231. begin
  1232.   inherited Remove(Popup);
  1233.   if Count = 0 then DeallocateHWnd(Window);
  1234. end;
  1235.  
  1236. constructor TPopupMenu.Create(AOwner: TComponent);
  1237. begin
  1238.   inherited Create(AOwner);
  1239.   FItems.OnClick := DoPopup;
  1240.   FWindowHandle := Application.Handle;
  1241.   FAutoPopup := True;
  1242.   PopupList.Add(Self);
  1243. end;
  1244.  
  1245. destructor TPopupMenu.Destroy;
  1246. begin
  1247.   PopupList.Remove(Self);
  1248.   inherited Destroy;
  1249. end;
  1250.  
  1251. procedure TPopupMenu.DoPopup(Item: TObject);
  1252. begin
  1253.   if Assigned(FOnPopup) then FOnPopup(Item);
  1254. end;
  1255.  
  1256. function TPopupMenu.GetHelpContext: THelpContext;
  1257. begin
  1258.   Result := FItems.HelpContext;
  1259. end;
  1260.  
  1261. procedure TPopupMenu.SetHelpContext(Value: THelpContext);
  1262. begin
  1263.   FItems.HelpContext := Value;
  1264. end;
  1265.  
  1266. procedure TPopupMenu.Popup(X, Y: Integer);
  1267. const
  1268.   Flags: array[TPopupAlignment] of Word = (TPM_LEFTALIGN, TPM_RIGHTALIGN,
  1269.     TPM_CENTERALIGN);
  1270. begin
  1271.   DoPopup(Self);
  1272.   TrackPopupMenu(FItems.Handle, Flags[FAlignment] or TPM_RIGHTBUTTON, X, Y,
  1273.     0 { reserved}, PopupList.Window, nil);
  1274. end;
  1275.  
  1276. { Menu building functions }
  1277.  
  1278. procedure InitMenuItems(AMenu: TMenu; Items: array of TMenuItem);
  1279. var
  1280.   I: Integer;
  1281.  
  1282.   procedure SetOwner(Item: TMenuItem);
  1283.   var
  1284.     I: Integer;
  1285.   begin
  1286.     if Item.Owner = nil then AMenu.Owner.InsertComponent(Item);
  1287.     for I := 0 to Item.Count - 1 do
  1288.       SetOwner(Item[I]);
  1289.   end;
  1290.  
  1291. begin
  1292.   for I := Low(Items) to High(Items) do
  1293.   begin
  1294.     SetOwner(Items[I]);
  1295.     AMenu.FItems.Add(Items[I]);
  1296.   end;
  1297. end;
  1298.  
  1299. function NewMenu(Owner: TComponent; const AName: string; Items: array of TMenuItem): TMainMenu;
  1300. begin
  1301.   Result := TMainMenu.Create(Owner);
  1302.   Result.Name := AName;
  1303.   InitMenuItems(Result, Items);
  1304. end;
  1305.  
  1306. function NewPopupMenu(Owner: TComponent; const AName: string;
  1307.   Alignment: TPopupAlignment; AutoPopup: Boolean; Items: array of TMenuItem): TPopupMenu;
  1308. begin
  1309.   Result := TPopupMenu.Create(Owner);
  1310.   Result.Name := AName;
  1311.   Result.AutoPopup := AutoPopup;
  1312.   Result.Alignment := Alignment;
  1313.   InitMenuItems(Result, Items);
  1314. end;
  1315.  
  1316. function NewSubMenu(const ACaption: string; hCtx: Word; const AName: string;
  1317.   Items: array of TMenuItem): TMenuItem;
  1318. var
  1319.   I: Integer;
  1320. begin
  1321.   Result := TMenuItem.Create(nil);
  1322.   for I := Low(Items) to High(Items) do
  1323.     Result.Add(Items[I]);
  1324.   Result.Caption := ACaption;
  1325.   Result.HelpContext := hCtx;
  1326.   Result.Name := AName;
  1327. end;
  1328.  
  1329. function NewItem(const ACaption: string; AShortCut: TShortCut;
  1330.   AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: Word;
  1331.   const AName: string): TMenuItem;
  1332. begin
  1333.   Result := TMenuItem.Create(nil);
  1334.   with Result do
  1335.   begin
  1336.     Caption := ACaption;
  1337.     ShortCut := AShortCut;
  1338.     OnClick := AOnClick;
  1339.     HelpContext := hCtx;
  1340.     Checked := AChecked;
  1341.     Enabled := AEnabled;
  1342.     Name := AName;
  1343.   end;
  1344. end;
  1345.  
  1346. function NewLine: TMenuItem;
  1347. begin
  1348.   Result := TMenuItem.Create(nil);
  1349.   Result.Caption := '-';
  1350. end;
  1351.  
  1352. initialization
  1353.   RegisterClasses([TMenuItem]);
  1354.   CommandPool := TBits.Create;
  1355.   PopupList := TPopupList.Create;
  1356. finalization
  1357.   PopupList.Free;
  1358.   CommandPool.Free;
  1359. end.
  1360.